home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 21 / Cream of the Crop 21 (Terry Blount) (October 1996).iso / program / srcbkvt.zip / 20_20_4.ZIP / SHDMEM.PAS < prev    next >
Pascal/Delphi Source File  |  1996-04-02  |  4KB  |  167 lines
  1. { Shared memory component -- Williams }
  2. unit shdmem;
  3.  
  4. interface
  5. uses Windows, Messages, Classes, Controls,SysUtils, DsgnIntf,
  6.   Forms, Dialogs;
  7.  
  8. type
  9.  
  10. TShareMem=class(TComponent)
  11. private
  12.   Ffilename : TFileName;  { File name }
  13.   FDeleteFlag : Bool;     { Delete on close? }
  14.   FFirstUser : Bool;      { First user? }
  15.   FNewFile : Bool;        { New file? }
  16.   fileh : THandle;        { File handle }
  17.   fmap : THandle;         { Handle to map }
  18.   addr : PChar;           { Base address }
  19.   Fcount : Integer;       { Number of strings }
  20.   FSize : Integer;        { Size of each string }
  21.   Mutex : THandle;        { Access Mutex }
  22.   FValid : Bool;          { Good flag }
  23. protected
  24.   { no protected declarations }
  25. public
  26.   constructor Create(obj : TComponent); override;
  27.   destructor Destroy; override;
  28.   procedure Loaded; override;
  29.   procedure UnLock;
  30.   procedure Clear;
  31.   function Rcl(n : integer;var s : String) : Bool;
  32.   function Sto(n : integer; s: String) : Bool;
  33.   function Lock(timeout : integer) : Bool;
  34.   Property FirstUser : Bool read FFirstUser;
  35.   Property NewFile: Bool read FNewFile;
  36.   Property FileHandle : THandle read fileh;
  37.   Property Valid : Bool read FValid;
  38. published
  39.   property Count : Integer read FCount write FCount default 100;
  40.   property Size : Integer read FSize write FSize default 256;
  41.   property Filename : TFileName read FFilename write FFilename;
  42.   Property DeleteFlag : Bool read FDeleteFlag write FDeleteFlag;
  43. end;
  44.  
  45. procedure Register;
  46.  
  47.  
  48. implementation
  49. procedure Register;
  50. begin
  51.   RegisterComponents('Samples', [TShareMem]);
  52. end;
  53.  
  54.  
  55. constructor TShareMem.Create(obj : TComponent);
  56. begin
  57.   inherited Create(obj);
  58. { Default setup }
  59.   FCount:=100;
  60.   FSize:=256;
  61.   Mutex:=0;
  62.   fileh:=-1;
  63.   FDeleteFlag:=False;
  64. end;
  65.  
  66. destructor TShareMem.Destroy;
  67. begin
  68. { Clear items }
  69.    if addr <> nil then
  70.      UnmapViewOfFile(addr);
  71.    if fmap <> 0 then
  72.      CloseHandle(fmap);
  73.    if fileh <> -1 then
  74.      CloseHandle(fileh);
  75.    if Mutex <> 0 then
  76.      CloseHandle(Mutex);
  77.    inherited Destroy;
  78. end;
  79.  
  80. procedure TShareMem.Loaded;
  81. var
  82.   delflag : Integer;
  83. begin
  84.   inherited Loaded;
  85. { Only load if not designing }
  86.   if not (csDesigning in ComponentState) then
  87.   begin
  88. { Create OR open file mapping -- if map exists, this
  89.    just opens it }
  90.   FValid:=True;  { Assume good things }
  91.   if (Fdeleteflag) then
  92.     delflag:=FILE_FLAG_DELETE_ON_CLOSE
  93.   else
  94.     delflag:=0;
  95.   if Ffilename <> '' then
  96.     fileh:=CreateFile(PChar(Ffilename),
  97.       GENERIC_READ or GENERIC_WRITE,0, nil,
  98.       OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL or delflag,0)
  99.   else
  100.     fileh:=THandle(-1);
  101.   if (fileh<>THandle(-1)) and
  102.      (GetLastError=Error_Already_Exists) then
  103.      FNewFile:=False
  104.   else
  105.      FNewFile:=True;
  106.   fmap:=CreateFileMapping(fileh,nil,PAGE_READWRITE,0,
  107.       FCount*FSize,PChar(Name));
  108.   if GetLastError=Error_Already_Exists then
  109.     FFirstUser:=False
  110.   else
  111.     FFirstUser:=True;
  112.   if fileh=THandle(-1) then
  113.     FNewFile:=FFirstUser;
  114.   if (fmap=THandle(0)) then FValid:=False;
  115.   addr:=MapViewOfFile(fmap,FILE_MAP_ALL_ACCESS,0,0,
  116.     FCount*FSize);
  117. { Create locking mutex }
  118.   Mutex:=CreateMutex(nil,FALSE,PChar(Name+'X'));
  119.   if Mutex=THandle(0) then FValid:=False;
  120.  end;
  121. end;
  122.  
  123.  
  124. function TShareMem.Rcl(n : integer;var s : String) : Bool;
  125. var
  126.     ps:PChar;
  127. begin
  128. { Lock, retrieve, and unlock }
  129.    Lock(INFINITE);
  130.    ps:=PChar(addr+(n*FSize));
  131.    s:=StrPas(ps);
  132.    Unlock;
  133.    result:=True;
  134. end;
  135.  
  136. function TShareMem.Sto(n : integer; s: String) : Bool;
  137. var
  138.    p: PChar;
  139. begin
  140. { Lock, store, and unlock }
  141.   Lock(INFINITE);
  142.   p:=PChar(addr+(n*FSize));
  143.   StrPCopy(p,s);
  144.   Unlock;
  145.   result:=True;
  146. end;
  147.  
  148.  function TShareMem.Lock(timeout : integer) : Bool;
  149.   begin
  150.     result:=WaitForSingleObject(Mutex,timeout)<>0;
  151.   end;
  152.  
  153. procedure TShareMem.Unlock;
  154.   begin
  155.     ReleaseMutex(Mutex);
  156.   end;
  157.  
  158.  
  159. procedure TShareMem.Clear;
  160. begin
  161.   Lock(INFINITE);
  162.   FillChar(addr^,FCount*FSize,0);
  163.   Unlock;
  164. end;
  165.  
  166. end.
  167.